home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / core-mixins.lisp < prev    next >
Text File  |  1991-07-15  |  18KB  |  507 lines
  1. ;;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                  P.O. BOX 149149                                 |
  8. ;;;                                AUSTIN, TEXAS 78714                               |
  9. ;;;                                                                                  |
  10. ;;;             Copyright (C) 1989, 1990 Texas Instruments Incorporated.             |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20.  
  21. (in-package "CLIO-OPEN")
  22.  
  23. (export '(
  24.       switch
  25.       
  26.       *default-contact-border*
  27.       *default-contact-foreground*
  28.       
  29.       core
  30.       core-shell
  31.       contact-foreground
  32.       contact-border
  33.       contact-scale
  34.       rescale
  35.  
  36.       *default-display-horizontal-space*
  37.       *default-display-vertical-space* 
  38.       display-horizontal-space
  39.       display-vertical-space
  40.       )
  41.     'clio-open)
  42.  
  43.  
  44.  
  45. (deftype switch ()
  46.   '(member :on :off))
  47.  
  48.  
  49.  
  50.  
  51. ;;;----------------------------------------------------------------------------+
  52. ;;;                                                                            |
  53. ;;;                                core-shell                                  |
  54. ;;;                                                                            |
  55. ;;;----------------------------------------------------------------------------+
  56.  
  57. (defcontact core-shell ()
  58.   ((scale      :type           (member :small :medium :large :extra-large)
  59.            :initarg           :scale
  60.            :initform       :medium
  61.            :accessor       contact-scale
  62.            :documentation  "The OPEN LOOK scale for the contact."))
  63.    (:resources
  64.      scale)
  65.    (:documentation "A base class for OPEN LOOK shells."))
  66.  
  67. (defmethod initialize-instance :after ((contact core-shell) &rest initargs)
  68.   (declare (ignore initargs))
  69.   (with-slots (background) contact
  70.     (when (eq :parent-relative background)
  71.       ;; Neither shell nor its owner specified a background...default to :white
  72.       (setf background (screen-white-pixel (contact-screen contact))))))
  73.  
  74.  
  75. ;;;----------------------------------------------------------------------------+
  76. ;;;                                                                            |
  77. ;;;                          Scale Implementation                           |
  78. ;;;  Strategy:                                       |
  79. ;;;    1. Remove scale slot from core class.                       |
  80. ;;;    2. Define new core-shell mixin to carry scale slot.               |
  81. ;;;    3. Add core-shell as superclass for all CLIO-OPEN shell classes.       |
  82. ;;;    4. Define contact-scale reader methods for all contacts.           |
  83. ;;;    5. Define (setf contact-scale) methods only for root and core-shell.   |
  84. ;;;                                                                            |
  85. ;;;----------------------------------------------------------------------------+
  86. ;;;
  87. ;;;   Nearly all contacts inherit scale from their parents...
  88. ;;;
  89. (defmethod contact-scale ((self contact))
  90.   (with-slots (parent) self
  91.     (contact-scale parent)))
  92.  
  93. (defparameter *default-root-scale* :medium)
  94.  
  95. ;;;
  96. ;;;   A root, lacking a parent, returns a default...
  97. ;;;
  98. (defmethod contact-scale ((self root))
  99.   ;; Contacts descended from a non-core-shell end up here...
  100.   *default-root-scale*)
  101.  
  102. ;;;
  103. ;;;   Changing the root's scale changes it for everyone...
  104. ;;;
  105. (defmethod (setf contact-scale) (new-value (self root))  
  106.   (setf *default-root-scale* new-value)
  107.  
  108.   ;; Propagate scale change to descendants
  109.   (while-changing-layout (self)
  110.     (rescale self))
  111.  
  112.   new-value)
  113.  
  114. ;;;
  115. ;;;   Trying to change a non-root non-top-level contact's scale changes is an error.
  116. ;;;
  117. (defmethod (setf contact-scale) (new-value (self contact))
  118.   (declare (ignore new-value))
  119.   (error "~s inherits scale from its ~:[top-level~;root~] ancestor." self (top-level-p self)))
  120.  
  121.  
  122. ;;;
  123. ;;;   Once a top-level shell's scale has been changed, propagate the effect of the change to all
  124. ;;;   its descendents...
  125. ;;;
  126. (defmethod (setf contact-scale) :after (new-value (self core-shell))
  127.   ;; Propagate scale change to descendants
  128.   (declare (ignore new-value))
  129.   (while-changing-layout (self)
  130.     (rescale self)))
  131.  
  132.  
  133. (defmethod rescale ((self composite))
  134.   (with-slots (children shells) self
  135.     ;; Rescale children.
  136.     (while-changing-layout (self)
  137.       (dolist (child children)
  138.     (rescale child))
  139.       (dolist (shell shells)
  140.     (setf (contact-scale shell) (contact-scale self))))))
  141.  
  142. (defmethod rescale ((self contact))
  143.   ;; Default is to resize to preferred size for new scale.
  144.   ;; Any changes to font, pixmaps, etc. should be done in a specialized :before
  145.   ;; method
  146.   (multiple-value-bind (width height bw) (preferred-size self :width 0 :height 0)
  147.     (change-geometry self
  148.              :width        width
  149.              :height       height
  150.              :border-width bw
  151.              :accept-p     t)))
  152.  
  153.  
  154.  
  155. ;;;----------------------------------------------------------------------------+
  156. ;;;                                                                            |
  157. ;;;                              core-wm-shell                                 |
  158. ;;;                                                                            |
  159. ;;;----------------------------------------------------------------------------+
  160.  
  161. (defcontact core-wm-shell (core-shell)
  162.   ((pinned-p   :type           boolean
  163.            :initarg           :pinned-p
  164.            :initform       nil
  165.            :accessor       contact-pinned-p))
  166.    
  167.    (:documentation "A base class for OPEN LOOK pop-up windows"))
  168.  
  169.  
  170. (defevent core-wm-shell (:property-notify :_ol_pin_state) update-pin-state)
  171.  
  172. (defmethod update-pin-state ((shell core-wm-shell))
  173.   (declare (type core-wm-shell shell))
  174.   (with-slots (pinned-p)
  175.     shell ;(the core-wm-shell shell)
  176.     (let ((previous (when pinned-p t)))
  177.       (unless
  178.     (or (setf pinned-p (= 1 (first (get-property shell  :_ol_pin_state))))
  179.         (eq pinned-p previous))
  180.     (setf (contact-state shell) :withdrawn)))))
  181.  
  182. (defmethod any-accept-focus-p ((contact contact))
  183.   (plusp (logand (cluei::contact-event-translations-mask contact)
  184.          #.(make-event-mask :key-press :key-release))))
  185.  
  186. (defmethod any-accept-focus-p ((composite composite))
  187.   (or (call-next-method) (with-slots (children) composite
  188.                (when (find-if #'any-accept-focus-p children) t))))
  189.  
  190. (defmethod realize :before ((self core-wm-shell))
  191.   ;; Initialize standard properties as needed by Open Look.
  192.   ;; Window group...
  193.   (unless (wm-group self)
  194.     ;; Group leader is base window owner (i.e. root shell)
  195.     (setf (wm-group self) (contact-root-shell self)))
  196.   
  197.   ;; Input focus... 
  198.   (unless (wm-keyboard-input self)
  199.     ;; By default, don't ask for window to perform set-input-focus.
  200.     (setf (wm-keyboard-input self) :off)
  201.     
  202.     ;; Use Globally Active model if keyboard input to descendants is possible.
  203.     (when (any-accept-focus-p self)
  204.       (setf (wm-protocols-used self)
  205.         (adjoin :WM_TAKE_FOCUS (wm-protocols-used self)))))
  206.   
  207.   ;; ICCCM protocols...
  208.   (setf (wm-protocols-used self)
  209.     (adjoin :WM_DELETE_WINDOW (wm-protocols-used self))))
  210.  
  211. (defmethod realize :after ((self core-wm-shell)) 
  212.   (with-slots ((contact-display display) pinned-p) self
  213.     (let ((display contact-display)) 
  214.  
  215.       ;; Set OLWM window type and initial push-pin.
  216.       (intern-atom display :_OL_WIN_ATTR)
  217.       (change-property
  218.     self :_OL_WIN_ATTR              
  219.     `(,(intern-atom display :_OL_WT_CMD)
  220.       ,(intern-atom display :_OL_MENU_LIMITED) 
  221.       , (intern-atom display (if pinned-p :_OL_PIN_IN :_OL_PIN_OUT)))
  222.     :_OL_WIN_ATTR
  223.     32)
  224.  
  225.       ;; Set OLWM protocols.
  226.       (intern-atom display :_OL_PROTOCOLS) 
  227.       (change-property
  228.     self :_OL_PROTOCOLS
  229.     `(,(intern-atom display :_OL_SCALE))
  230.     :ATOM
  231.     32))))
  232.  
  233.  
  234.  
  235. ;;;----------------------------------------------------------------------------+
  236. ;;;                                                                            |
  237. ;;;                                   core                                     |
  238. ;;;                                                                            |
  239. ;;;----------------------------------------------------------------------------+
  240.  
  241. (defparameter *default-contact-border*
  242.           :black)
  243.  
  244. (defparameter *default-contact-foreground*
  245.           :black)
  246.  
  247. (defcontact core ()
  248.   ((border     :type           (or (member :copy) pixel pixmap)
  249.            :initform        *default-contact-border*
  250.            :initarg        :border
  251.            :reader         contact-border            ; setf defined below
  252.            :documentation  "Contents of the contact border.")
  253.    (foreground :type           pixel
  254.            :initarg           :foreground
  255.            :reader         contact-foreground    ; setf defined below
  256.            :documentation  "The foreground color for the contact."))
  257.   
  258.   (:resources border foreground)
  259.   (:documentation "Base class for all core contacts."))
  260.  
  261. (defmethod initialize-instance :after ((contact core) &rest initargs)
  262.   (declare (ignore initargs))
  263.   (with-slots (foreground) contact
  264.     (unless foreground
  265.       (assert
  266.     (setf foreground (or (inherited-foreground contact)
  267.                  (convert contact *default-contact-foreground* 'pixel)))
  268.     nil
  269.     "Default foreground color is ~a, which cannot be converted to a pixel."
  270.     *default-contact-foreground*))))
  271.  
  272. (defmethod inherited-foreground ((contact contact))
  273.   (with-slots (parent) contact
  274.     (contact-foreground parent)))
  275.  
  276. (defmethod inherited-foreground ((contact shell))
  277.   (contact-foreground (shell-owner contact)))
  278.   
  279. (defmethod (setf contact-border) (new-border (contact core))
  280.   (with-slots (border) contact
  281.     (let ((converted-border (convert contact new-border '(or pixel pixmap (member :copy)))))
  282.       (assert converted-border nil "~a cannot be converted to PIXEL, PIXMAP, or :COPY." new-border)
  283.       (unless (eql border converted-border)
  284.     (setf border converted-border)
  285.     (setf (window-border contact) converted-border)))
  286.     border))
  287.  
  288. (defmethod (setf contact-foreground) (new-foreground (contact core))
  289.   (with-slots (foreground) contact
  290.     (let ((converted-foreground (convert contact new-foreground 'pixel)))
  291.       (assert converted-foreground nil "~a cannot be converted to a PIXEL." new-foreground)
  292.       (unless (eql foreground converted-foreground)
  293.     (setf foreground converted-foreground)
  294.     (clear-area contact :exposures-p t)))
  295.     foreground))
  296.  
  297. (defmethod contact-foreground (object)
  298.   (declare (ignore object))
  299.   ;; Default method for non-core objects.
  300.   nil)
  301.  
  302.  
  303.  
  304. ;;;----------------------------------------------------------------------------+
  305. ;;;                                                                            |
  306. ;;;                                Font Handling                               |
  307. ;;;                                                                            |
  308. ;;;----------------------------------------------------------------------------+
  309.  
  310. (defparameter *open-look-scale-fontnames*
  311.           '(
  312.         :small       "-*-lucida-*-r-normal-sans-10-*-*-*-p-*-*-*"
  313.         :medium      "-*-lucida-*-r-normal-sans-12-*-*-*-p-*-*-*"
  314.         :large       "-*-lucida-*-r-normal-sans-14-*-*-*-p-*-*-*"
  315.         :extra-large "-*-lucida-*-r-normal-sans-19-*-*-*-p-*-*-*"
  316.         )
  317.   "These are the fontnames used to implement Open Look, if available.
  318. Modify these if you want to override CLIO's use of Open Look fonts.")
  319.  
  320. (defparameter *default-scale-fontnames*
  321.           '(
  322.         :small       "-*-helvetica-*-r-*-*-10-*-*-*-p-*-*-*"
  323.         :medium      "-*-helvetica-*-r-*-*-12-*-*-*-p-*-*-*"
  324.         :large       "-*-helvetica-*-r-*-*-14-*-*-*-p-*-*-*"
  325.         :extra-large "-*-charter-*-r-*-*-19-*-*-*-p-*-*-*"
  326.         )
  327.   "If standard Open Look are not available, use these fontname
  328. attributes for each scale.") 
  329.  
  330.  
  331. (defmethod find-font ((contact core) fontname)
  332.   (declare (type fontable fontname)
  333.        (values (or null font)))
  334.   (flet
  335.     ((find-font-attributes (attributes fontnames)
  336.         ;; Assert:
  337.         ;;   ATTRIBUTES is a fully-qualified fontname.
  338.         ;;   FONTNAMES is a list of fully-qualified fontnames.
  339.         
  340.         ;; Return a member of FONTNAMES that matches ATTRIBUTES for every
  341.     ;; non-* component of ATTRIBUTES.
  342.                
  343.         (let ((lengtha (length attributes)))
  344.       (dolist (fontname fontnames)
  345.         (when
  346.           ;; Does this fontname match?
  347.           (do
  348.         (
  349.          ;; Start/end of next component of attributes.
  350.          (starta 0 (min lengtha (1+ enda)))
  351.          enda
  352.          
  353.          ;; Start/end of next component of fontname.
  354.          (startf 0 (min lengthf (1+ endf)))
  355.          endf
  356.          (lengthf (length fontname)))
  357.         
  358.         ;; If finished scanning, return match.
  359.         ((and (>= starta lengtha) (>= startf lengthf)) t)
  360.         
  361.         ;; Find end of next component.
  362.         (setf enda (or (position #\- attributes :start starta) lengtha))
  363.         (setf endf (or (position #\- fontname   :start startf) lengthf))
  364.  
  365.         (unless
  366.           (or
  367.             ;; Is next attributes component is *?
  368.             (string-equal attributes "*" :start1 starta :end1 enda)
  369.             
  370.             ;; Does corresponding fontname component match?
  371.             (string-equal
  372.               fontname attributes
  373.               :start1 startf :end1 endf :start2 starta :end2 enda))
  374.           
  375.           ;; No, match failed...try next fontname
  376.           (return nil)))
  377.           
  378.           (return fontname))))))
  379.     
  380.     (let* ((display  (contact-display contact))
  381.        (scale    (contact-scale contact))
  382.        
  383.        ;; Get requested fontname string.
  384.        (fontname (etypecase fontname
  385.                (font    (font-name fontname))
  386.                (string  fontname)
  387.                (null    "*")
  388.                (symbol  (symbol-name fontname))))
  389.        
  390.        (cache    (getf (display-plist display) 'fontnames)))
  391.       
  392.       (or
  393.     ;; Already found in fontname cache?
  394.     (third (find-if
  395.          #'(lambda (entry) (and (eq (first entry) scale)
  396.                     (string-equal (second entry) fontname)))
  397.          cache))
  398.     
  399.     ;; No, create new fontname cache entry.
  400.     (let*
  401.       ;; Get (fully-qualified) fontnames matching request. 
  402.       ((requested
  403.          (delete-if #'(lambda (name) (not (find #\- name)))
  404.             (list-font-names display fontname)))
  405.        
  406.        ;; Find fontname that best matches given fontname+Open Look requirements.
  407.        (best-match
  408.          (open-font
  409.            display
  410.            (or
  411.          (let ((ol-required (getf *open-look-scale-fontnames* scale))) 
  412.            (or
  413.              ;; Find one matching Open Look requirements?
  414.              (find-font-attributes ol-required requested)
  415.              
  416.              ;; Find appropriate Open Look font for scale?
  417.              (when (list-font-names display ol-required)
  418.                ol-required)))
  419.          
  420.          (let ((ol-requested (getf *default-scale-fontnames* scale))) 
  421.            (or
  422.              ;; Find one matching Open Look suggestions?
  423.              (find-font-attributes ol-requested requested)
  424.              
  425.              ;; Find appropriate suggested font for scale?
  426.              (when (list-font-names display ol-requested)
  427.                ol-requested)))
  428.          
  429.          ;; Given fontname exists?
  430.          (when (list-font-names display fontname)
  431.            fontname)
  432.          
  433.          ;; Last resort is to use "fixed" font.
  434.          "fixed"))))
  435.       
  436.       ;; Add match to cache.
  437.       (setf (getf (display-plist display) 'fontnames)
  438.         (nconc `((,scale ,fontname ,best-match)) cache))
  439.       best-match)))))
  440.  
  441.  
  442. ;;;----------------------------------------------------------------------------+
  443. ;;;                                                                            |
  444. ;;;                                spacing-mixin                               |
  445. ;;;                                                                            |
  446. ;;;----------------------------------------------------------------------------+
  447.  
  448.  
  449. (defparameter *default-display-horizontal-space* 0
  450.   "The default size of the horizontal spacing, in points.")
  451.  
  452. (defparameter *default-display-vertical-space* 0
  453.   "The default size of the vertical spacing, in points.")
  454.  
  455.  
  456.  
  457. ;;;  Special types to support conversion of resource defaults to pixel units
  458. (deftype default-horizontal-space () 'integer)
  459. (deftype default-vertical-space   () 'integer)
  460.  
  461.  
  462.  
  463. (defmethod convert ((contact contact) (value (eql :default)) (type (eql 'default-horizontal-space)))
  464.   (point-pixels (contact-screen contact) *default-display-horizontal-space*))
  465.  
  466. (defmethod convert ((contact contact) (value (eql :default)) (type (eql 'default-vertical-space)))
  467.   (point-pixels (contact-screen contact) *default-display-vertical-space*))
  468.  
  469.  
  470.  
  471. (defcontact spacing-mixin ()
  472.   ((horizontal-space :type         integer
  473.              :initarg         :horizontal-space
  474.              :reader          display-horizontal-space    ; setf defined below
  475.              :documentation  "The size of the horizontal spacing in pixels")
  476.    (vertical-space   :type         integer
  477.              :initarg         :vertical-space
  478.              :reader          display-vertical-space    ; setf defined below
  479.              :documentation  "The size of the vertical spacing in pixels"))
  480.   (:resources
  481.     (horizontal-space :type     default-horizontal-space
  482.               :initform :default)
  483.     (vertical-space   :type     default-vertical-space
  484.               :initform :default))
  485.   
  486.   (:documentation  "Provides horizontal and vertical spacing resources for core contacts"))
  487.  
  488.  
  489.  
  490.  
  491. (defmethod (setf display-horizontal-space) (new-value (contact spacing-mixin))
  492.   (with-slots (horizontal-space) contact
  493.     (check-type new-value (or (member :default) integer) ":DEFAULT or INTEGER")
  494.     (setf horizontal-space (if (eq :default new-value)
  495.                    (convert contact new-value 'default-horizontal-space)
  496.                    new-value))))
  497.  
  498.  
  499.  
  500. (defmethod (setf display-vertical-space) (new-value (contact spacing-mixin))
  501.   (with-slots (vertical-space) contact
  502.     (check-type new-value (or (member :default) integer) ":DEFAULT or INTEGER")
  503.     (setf vertical-space (if (eq :default new-value)
  504.                    (convert contact new-value 'default-vertical-space)
  505.                    new-value))))
  506.  
  507.